home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Windows Expert
/
Windows Expert.iso
/
windownt
/
perlnt.zip
/
eg
/
h2ph.cmd
< prev
next >
Wrap
OS/2 REXX Batch file
|
1993-07-25
|
5KB
|
217 lines
@rem = '-*- Perl -*-';
@rem = '
@echo off
perl -S %0.cmd %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
';
#$perlincl = 'c:/win32app/ingr/perl/inc';
$perlincl = 'e:/perl-4.036/inc';
$incdir = 'd:/mstools/h';
@isatype = split(' ',<<END);
char uchar u_char
short ushort u_short
int uint u_int
long ulong u_long
FILE
END
@isatype{@isatype} = (1) x @isatype;
#@ARGV = ('-') unless @ARGV;
opendir(D, $incdir) || die "can'd open $incdir directory";
@dirs = readdir (D);
closedir D;
@ARGV = grep (/^.*\.h$/i, @dirs);
foreach $file (@ARGV) {
if ($file eq '-') {
open(IN, "-");
open(OUT, ">-");
}
else {
($outfile = $file) =~ s/\.h$/.ph/i || next;
print "$file -> $outfile\n";
if ($file =~ m|^(.*)/|) {
$dir = $1;
if (!-d "$perlincl/$dir") {
mkdir("$perlincl/$dir",0777);
}
}
open(IN,"$incdir/$file")
|| ((warn "Can't open $incdir/$file: $!\n"),next);
open(OUT,">$perlincl/$outfile")
|| die "Can't create $outfile: $!\n";
}
while (<IN>) {
chop;
while (/\\$/) {
chop;
$_ .= <IN>;
chop;
}
if (s:/\*:\200:g) {
s:\*/:\201:g;
s/\200[^\201]*\201//g; # delete single line comments
if (s/\200.*//) { # begin multi-line comment?
$_ .= '/*';
$_ .= <IN>;
redo;
}
}
if (s/^#\s*//) {
if (s/^define\s+(\w+)//) {
$name = $1;
$new = '';
s/\s+$//;
if (s/^\(([\w,\s]*)\)//) {
$args = $1;
if ($args ne '') {
foreach $arg (split(/,\s*/,$args)) {
$arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
$curargs{$arg} = 1;
}
$args =~ s/\b(\w)/\$$1/g;
$args = "local($args) = \@_;\n$t ";
}
s/^\s+//;
do expr();
$new =~ s/(["\\])/\\$1/g;
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g;
print OUT $t,
"eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n";
}
else {
print OUT "sub $name {\n ${args}eval \"$new\";\n}\n";
}
%curargs = ();
}
else {
s/^\s+//;
do expr();
$new = 1 if $new eq '';
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g;
print OUT $t,"eval 'sub $name {",$new,";}';\n";
}
else {
print OUT $t,"sub $name {",$new,";}\n";
}
}
}
elsif (/^include\s+<(.*)>/) {
($incl = $1) =~ s/\.h$/.ph/;
print OUT $t,"require '$incl';\n";
}
elsif (/^ifdef\s+(\w+)/) {
print OUT $t,"if (defined &$1) {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
}
elsif (/^ifndef\s+(\w+)/) {
print OUT $t,"if (!defined &$1) {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
}
elsif (s/^if\s+//) {
$new = '';
do expr();
print OUT $t,"if ($new) {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
}
elsif (s/^elif\s+//) {
$new = '';
do expr();
$tab -= 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT $t,"}\n${t}elsif ($new) {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
}
elsif (/^else/) {
$tab -= 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT $t,"}\n${t}else {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
}
elsif (/^endif/) {
$tab -= 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT $t,"}\n";
}
}
}
print OUT "1;\n";
}
sub expr {
while ($_ ne '') {
s/^(\s+)// && do {$new .= ' '; next;};
s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;};
s/^(\d+)// && do {$new .= $1; next;};
s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
s/^'((\\"|[^"])*)'// && do {
if ($curargs{$1}) {
$new .= "ord('\$$1')";
}
else {
$new .= "ord('$1')";
}
next;
};
s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
$new .= '$sizeof';
next;
};
s/^([_a-zA-Z]\w*)// && do {
$id = $1;
if ($id eq 'struct') {
s/^\s+(\w+)//;
$id .= ' ' . $1;
$isatype{$id} = 1;
}
elsif ($id eq 'unsigned') {
s/^\s+(\w+)//;
$id .= ' ' . $1;
$isatype{$id} = 1;
}
if ($curargs{$id}) {
$new .= '$' . $id;
}
elsif ($id eq 'defined') {
$new .= 'defined';
}
elsif (/^\(/) {
s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
$new .= " &$id";
}
elsif ($isatype{$id}) {
if ($new =~ /{\s*$/) {
$new .= "'$id'";
}
elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
$new =~ s/\(\s*$//;
s/^[\s*]*\)//;
}
else {
$new .= $id;
}
}
else {
$new .= ' &' . $id;
}
next;
};
s/^(.)// && do {$new .= $1; next;};
}
}
__END__
:endofperl